home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / packages / paren.el.z / paren.el
Encoding:
Text File  |  1998-05-21  |  13.4 KB  |  396 lines
  1. ;;; paren.el --- highlight (un)matching parens and whole expressions
  2.  
  3. ;; Copyright (C) 1993 Free Software Foundation, Inc.
  4. ;; Copyright (C) 1993, 1994, 1995 Tinker Systems
  5. ;;
  6. ;; Author: Jonathan Stigelman <Stig@hackvan.com>
  7. ;; Note:   (some code scammed from simple.el and blink-paren.el)
  8. ;; Maintainer: Jonathan Stigelman <Stig@hackvan.com>
  9. ;; Keywords: languages, faces
  10.  
  11. ;;; This file is part of XEmacs.
  12. ;;; 
  13. ;;; XEmacs is free software; you can redistribute it and/or modify
  14. ;;; it under the terms of the GNU General Public License as published by
  15. ;;; the Free Software Foundation; either version 2 of the License, or
  16. ;;; (at your option) any later version.
  17. ;;; 
  18. ;;; XEmacs is distributed in the hope that it will be useful,
  19. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21. ;;; GNU General Public License for more details.
  22. ;;; 
  23. ;;; You should have received a copy of the GNU General Public License
  24. ;;; along with XEmacs; if not, write to the Free Software
  25. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  26.  
  27. ;;; Synched up with: Not synched with FSF.
  28. ;;; Way different from FSF.
  29.  
  30. ;;; Commentary:
  31.  
  32. ;; Purpose of this package:
  33. ;;
  34. ;;   This package highlights matching parens (or whole sexps) for easier
  35. ;;   editing of source code, particularly lisp source code.
  36. ;; 
  37. ;; The `paren-highlight' hook function runs after each command and
  38. ;; checks to see if the cursor is at a parenthesis.  If so, then it
  39. ;; highlights, in one of several ways, the matching parenthesis.
  40. ;; 
  41. ;; Priority is given to matching parentheses right before the cursor because
  42. ;; that's what makes sense when you're typing a lot of closed parentheses.
  43. ;; 
  44. ;; This is especially intuitive if you frequently use forward-sexp (M-C-f)
  45. ;; and backward-sexp (M-C-b) to maneuver around in source code.
  46. ;; 
  47. ;; Different faces are used for matching and mismatching parens so that it
  48. ;; is easier to see mistakes as you type them.  Audible feedback is optional.
  49. ;; 
  50. ;; If a (mis)matching paren is offscreen, then a message is sent to the modeline.
  51. ;; 
  52. ;; If paren-mode is `sexp', entire S-expressions are highlighted instead of
  53. ;; just matching parens.
  54.  
  55. ;;; Code:
  56.  
  57. (defgroup paren-matching nil
  58.   "Highlight (un)matching of parens and expressions."
  59.   :prefix "paren-"
  60.   :group 'matching)
  61.  
  62.  
  63. ;;;###autoload
  64. (defcustom paren-mode nil
  65.   "*Sets the style of parenthesis highlighting.
  66. Valid values are nil, `blink-paren', `paren', and `sexp'.
  67.   nil        no parenthesis highlighting.
  68.   blink-paren    causes the matching paren to blink.
  69.   paren        causes the matching paren to be highlighted but not to blink.
  70.   sexp        whole expression enclosed by the local paren at its mate.
  71.   nested    (not yet implemented) use variable shading to see the
  72.         nesting of an expression.  Also groks regular expressions
  73.         and shell quoting.
  74.  
  75. This variable is global by default, but you can make it buffer-local and
  76. highlight parentheses differently in different major modes."
  77.   :type '(radio (const :tag "None (default)" nil)
  78.         (const :tag "Blinking Paren" blink-paren)
  79.         (const :tag "Highlighted Paren" paren)
  80.         (const :tag "Highlighted Expression" sexp))
  81.   :set (lambda (symbol value)
  82.      (paren-set-mode value))
  83.   :initialize 'custom-initialize-default
  84.   :require 'paren
  85.   :group 'paren-matching)
  86.  
  87. (defcustom paren-message-offscreen t
  88.   "*Display message if matching open paren is offscreen."
  89.   :type 'boolean
  90.   :group 'paren-matching)
  91.  
  92. (defcustom paren-ding-unmatched nil
  93.   "*Make noise if the cursor is at an unmatched paren.
  94.  
  95. If T, then typing or passing over an unmatched paren will ring the bell
  96. using the `paren' sound.  If NIL, then the bell will not ring even if an
  97. unmatched paren is typed.  If neither T or NIL, then the bell will not ring
  98. when the cursor moves over unmatched parens but will ring if one is typed."
  99.   :type '(choice (const :tag "off" nil)
  100.          (const :tag "on" t)
  101.          (const :tag "other" other))
  102.   :group 'paren-matching)
  103.  
  104. (make-face 'paren-match)
  105. (or (face-differs-from-default-p 'paren-match)
  106.     (copy-face 'highlight 'paren-match))
  107.  
  108. (make-face 'paren-mismatch)
  109. (cond ((face-differs-from-default-p 'paren-mismatch) nil)
  110.       (t (let ((color-tag (list 'x 'color))
  111.            (mono-tag (list 'x 'mono))
  112.            (gray-tag (list 'x 'grayscale)))
  113.        (set-face-background 'paren-mismatch "DeepPink" 'global color-tag)
  114.        (set-face-reverse-p 'paren-mismatch t 'global 'tty)
  115.        (set-face-background 'paren-mismatch [modeline background] 'global
  116.                 mono-tag)
  117.        (set-face-foreground 'paren-mismatch [modeline foreground] 'global
  118.                 mono-tag)
  119.        (set-face-background 'paren-mismatch [modeline background] 'global
  120.                 gray-tag)
  121.        (set-face-foreground 'paren-mismatch [modeline foreground] 'global
  122.                 gray-tag))))
  123.  
  124. (make-face 'paren-blink-off)
  125. (or (face-differs-from-default-p 'paren-blink-off)
  126.     (set-face-foreground 'paren-blink-off (face-background 'default)))
  127.  
  128. ;; this is either paren-match or paren-mismatch...
  129. (defvar paren-blink-on-face nil)
  130.  
  131. (defcustom paren-blink-interval 0.2
  132.   "*If the cursor is on a parenthesis, the matching parenthesis will blink.
  133. This variable controls how long each phase of the blink lasts in seconds.
  134. This should be a fractional part of a second (a float.)"
  135.   :type 'number
  136.   :group 'paren-matching)
  137.  
  138. (defcustom paren-max-blinks (* 5 60 5)    ; 5 minutes is plenty...
  139.   ;; idea from Eric Eide <eeide@jaguar.cs.utah.edu>
  140.   "*Maximum number of times that a matching parenthesis will blink.
  141. Set this to NIL if you want indefinite blinking."
  142.   :type 'number
  143.   :group 'paren-matching)
  144.  
  145. ;; timeout to blink the face
  146. (defvar paren-timeout-id nil)
  147.  
  148. ;; Code:
  149.  
  150. (defvar paren-n-blinks)
  151. (defvar paren-extent nil)
  152.  
  153. ;; used to suppress messages from the same position so that other messages
  154. ;; can be seen in the modeline.
  155. (make-variable-buffer-local
  156.  (defvar paren-message-suppress nil))
  157.  
  158. (defsubst pos-visible-in-window-safe (pos)
  159.   "safe version of pos-visible-in-window-p"
  160.   (condition-case nil
  161.       ;; #### - is this needed in XEmacs???
  162.       (pos-visible-in-window-p pos)
  163.       (args-out-of-range nil)))
  164.  
  165. ;; called before a new command is executed in the pre-command-hook
  166. ;; cleanup by removing the extent and the time-out
  167. (defun paren-nuke-extent ()
  168.   (condition-case c  ; don't ever signal an error in pre-command-hook!
  169.       (let ((inhibit-quit t))
  170.     (if paren-timeout-id
  171.         (disable-timeout (prog1 paren-timeout-id
  172.                    (setq paren-timeout-id nil))))
  173.     (if paren-extent
  174.         (delete-extent (prog1 paren-extent
  175.                  (setq paren-extent nil)))))
  176.     (error
  177.      (message "paren-nuke-extent error! %s" c))))
  178.  
  179. ;; callback for the timeout
  180. ;; swap the face of the extent on the matching paren
  181. (defun paren-blink-timeout (arg)
  182.   ;; The extent could have been deleted for some reason and not point to a
  183.   ;; buffer anymore.  So catch any error to remove the timeout.
  184.   (condition-case ()
  185.       (if (and paren-max-blinks
  186.            (> (setq paren-n-blinks (1+ paren-n-blinks)) paren-max-blinks))
  187.       (paren-nuke-extent)
  188.     (set-extent-face paren-extent 
  189.              (if (eq (extent-face paren-extent)
  190.                  paren-blink-on-face)
  191.                  'paren-blink-off
  192.                paren-blink-on-face)))
  193.     (error (paren-nuke-extent))))
  194.  
  195.  
  196. (defun paren-describe-match (pos mismatch)  
  197.   (or (window-minibuffer-p (selected-window))
  198.       (save-excursion
  199.     (goto-char pos)
  200.     (message "%s %s"
  201.          (if mismatch "MISMATCH:" "Matches")
  202.          ;; if there's stuff on this line preceding the paren, then
  203.          ;; display text from beginning of line to paren.
  204.          ;;
  205.          ;; If, however, the paren is at the beginning of a line, then
  206.          ;; skip whitespace forward and display text from paren to end
  207.          ;; of the next line containing nonspace text.
  208.          ;;
  209.          ;; If paren-backwards-message gravity were implemented, then
  210.          ;; perhaps it would reverse this behavior and look to the
  211.          ;; previous line for meaningful context.
  212.          (if (save-excursion
  213.                (skip-chars-backward " \t")
  214.                (not (bolp)))
  215.              (concat (buffer-substring
  216.                   (progn (beginning-of-line) (point))
  217.                   (1+ pos)) "...")
  218.            (buffer-substring
  219.             pos (progn
  220.               (forward-char 1)
  221.               (skip-chars-forward "\n \t")
  222.               (end-of-line)
  223.               (point))))))))
  224.  
  225. (defun paren-maybe-ding ()
  226.   (and (or (eq paren-ding-unmatched t)
  227.        (and paren-ding-unmatched
  228.         (eq this-command 'self-insert-command)))
  229.        (progn
  230.      (message "Unmatched parenthesis.")
  231.      (ding nil 'paren))))
  232.  
  233. ;; Find the place to show, if there is one,
  234. ;; and show it until input arrives.
  235. (defun paren-highlight ()
  236.   "This highlights matching parentheses.
  237.  
  238. See the variables:
  239.   paren-message-offscreen   use modeline when matchingparen is offscreen?
  240.   paren-ding-unmatched        make noise when passing over mismatched parens?
  241.   paren-mode            'blink-paren, 'paren, or 'sexp
  242.   blink-matching-paren-distance  maximum distance to search for parens.
  243.  
  244. and the following faces:
  245.   paren-match, paren-mismatch, paren-blink-off"
  246.  
  247.   ;; I suppose I could check here to see if a keyboard macro is executing,
  248.   ;; but I did a quick empirical check and couldn't tell that there was any
  249.   ;; difference in performance
  250.  
  251.   (let ((oldpos (point))
  252.     (pface nil)            ; face for paren...nil kills the overlay
  253.     (dir (and paren-mode
  254.           (not (input-pending-p))
  255.           (not executing-kbd-macro)
  256.           (cond ((eq (char-syntax (preceding-char)) ?\))
  257.              -1)
  258.             ((eq (char-syntax (following-char)) ?\()
  259.              1))))
  260.     pos mismatch)
  261.  
  262.     (save-excursion
  263.       (if (or (not dir)
  264.           (not (save-restriction
  265.              ;; Determine the range within which to look for a match.
  266.              (if blink-matching-paren-distance
  267.              (narrow-to-region
  268.               (max (point-min)
  269.                    (- (point) blink-matching-paren-distance))
  270.               (min (point-max)
  271.                    (+ (point) blink-matching-paren-distance))))
  272.  
  273.              ;; Scan across one sexp within that range.
  274.              (condition-case nil
  275.              (setq pos (scan-sexps (point) dir))
  276.                ;; NOTE - if blink-matching-paren-distance is set,
  277.                ;; then we can have spurious unmatched parens.
  278.                (error (paren-maybe-ding)
  279.                   nil)))))
  280.  
  281.       ;; do nothing if we didn't find a matching paren...
  282.       nil
  283.  
  284.     ;; See if the "matching" paren is the right kind of paren
  285.     ;; to match the one we started at.
  286.     (let ((beg (min pos oldpos)) (end (max pos oldpos)))
  287.       (setq mismatch
  288.         (and (/= (char-syntax (char-after beg)) ?\\)
  289.              (/= (char-syntax (char-after beg)) ?\$)
  290.              ;; XEmacs change
  291.              (matching-paren (char-after beg))
  292.              (/= (char-after (1- end))
  293.              (matching-paren (char-after beg)))))
  294.       (if (eq paren-mode 'sexp)
  295.           (setq paren-extent (make-extent beg end))))
  296.     (and mismatch
  297.          (paren-maybe-ding))
  298.      (setq pface (if mismatch
  299.             'paren-mismatch
  300.               'paren-match))
  301.     (and (memq paren-mode '(blink-paren paren))
  302.          (setq paren-extent (make-extent (- pos dir) pos)))
  303.  
  304.     (if (and paren-message-offscreen
  305.          (eq dir -1)
  306.          (not (eq paren-message-suppress (point)))
  307.          (not (window-minibuffer-p (selected-window)))
  308.          (not (pos-visible-in-window-safe pos)))
  309.         (progn
  310.           (setq paren-message-suppress (point))
  311.           (paren-describe-match pos mismatch))
  312.       (setq paren-message-suppress nil))
  313.          
  314.     ;; put the right face on the extent
  315.     (cond (pface
  316.            (set-extent-face paren-extent pface) 
  317.            (set-extent-priority paren-extent 100) ; want this to be high
  318.            (and (eq paren-mode 'blink-paren)
  319.             (setq paren-blink-on-face pface
  320.               paren-n-blinks 0
  321.               paren-timeout-id
  322.               (and paren-blink-interval
  323.                    (add-timeout paren-blink-interval
  324.                         'paren-blink-timeout
  325.                         nil
  326.                         paren-blink-interval))))))
  327.     ))))
  328.  
  329.  
  330. ;;;###autoload
  331. (defun paren-set-mode (arg &optional quiet)
  332.   "Cycles through possible values for `paren-mode', force off with negative arg.
  333. When called from lisp, a symbolic value for `paren-mode' can be passed directly.
  334. See also `paren-mode' and `paren-highlight'."
  335.   (interactive "P")
  336.   ;; kill off the competition, er, uh, eliminate redundancy...
  337.   (setq post-command-hook (delq 'show-paren-command-hook post-command-hook))
  338.   (setq pre-command-hook (delq 'blink-paren-pre-command pre-command-hook))
  339.   (setq post-command-hook (delq 'blink-paren-post-command post-command-hook))
  340.  
  341.   (let* ((paren-modes '(blink-paren paren sexp))
  342.      (paren-next-modes (cons nil (append paren-modes (list nil)))))
  343.     (setq paren-mode (if (and (numberp arg) (< arg 0))
  344.              nil        ; turn paren highlighting off
  345.                (cond ((and arg (symbolp arg)) arg)
  346.                  ((and (numberp arg) (> arg 0))
  347.                   (nth (1- arg) paren-modes))
  348.                  ((numberp arg) nil)
  349.                  (t (car (cdr (memq paren-mode
  350.                         paren-next-modes)))))
  351.                )))
  352.   (cond (paren-mode
  353.      (add-hook 'post-command-hook 'paren-highlight)
  354.      (add-hook 'pre-command-hook 'paren-nuke-extent)
  355.      (setq blink-matching-paren nil))
  356.     ((not (local-variable-p 'paren-mode (current-buffer)))
  357.      (remove-hook 'post-command-hook 'paren-highlight)
  358.      (remove-hook 'pre-command-hook 'paren-nuke-extent)
  359.      (paren-nuke-extent)        ; overkill
  360.      (setq blink-matching-paren t)
  361.      ))
  362.   (or quiet (message "Paren mode is %s" (or paren-mode "OFF"))))
  363.  
  364. (eval-when-compile
  365.   ;; suppress compiler warning.
  366.   (defvar highlight-paren-expression))
  367.  
  368. ;; No no no!
  369. ;(paren-set-mode (if (and (boundp 'highlight-paren-expression)
  370. ;                ;; bletcherous blink-paren no-naming-convention
  371. ;                highlight-paren-expression)
  372. ;               'sexp
  373. ;             (if (eq 'x (device-type (selected-device)))
  374. ;             'blink-paren
  375. ;               'paren))
  376. ;        t)
  377.  
  378. ;;;###autoload
  379. (make-obsolete 'blink-paren 'paren-set-mode)
  380.  
  381. ;;;###autoload
  382. (defun blink-paren (&optional arg)
  383.   "Obsolete.  Use `paren-set-mode' instead."
  384.   (interactive "P") 
  385.   (paren-set-mode (if (and (numberp arg) (> arg 0))
  386.               'blink-paren -1) t))
  387.  
  388. (provide 'blink-paren)
  389. (provide 'paren)
  390.  
  391. ;; Local Variables:
  392. ;; byte-optimize: t
  393. ;; End:
  394.  
  395. ;;; paren.el ends here
  396.